home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / modes / hideshow.el < prev    next >
Encoding:
Text File  |  1995-07-05  |  17.7 KB  |  491 lines
  1. ;;; hideshow.el --- minor mode cmds to selectively display blocks of code
  2.  
  3. ;;; Copyright (C) 1994,1995 Free Software Foundation
  4.  
  5. ;;; Author: Thien-Thi Nguyen <ttn@netcom.com>
  6. ;;; Version: 3.4
  7. ;;; Keywords: C C++ lisp tools editing
  8. ;;; Time-of-Day-Author-Most-Likely-to-be-Recalcitrant: early morning
  9.  
  10. ;;; This file is part of GNU Emacs.
  11.  
  12. ;;; GNU Emacs is free software; you can redistribute it and/or modify it
  13. ;;; under the terms of the GNU General Public License as published by the
  14. ;;; Free Software Foundation; either version 2 of the License, or (at your
  15. ;;; option) any later version.
  16. ;;; 
  17. ;;; GNU Emacs is distributed in the hope that it will be useful, but WITHOUT
  18. ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  19. ;;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  20. ;;; for more details.
  21. ;;; 
  22. ;;; You should have received a copy of the GNU General Public License along
  23. ;;; with this program; if not, write to the Free Software Foundation, Inc.,
  24. ;;; 675 Mass Ave, Cambridge, MA 02139, USA.
  25.  
  26. ;;; LCD Archive Entry:
  27. ;;; hideshow|Thien-Thi Nguyen|ttn@netcom.com|
  28. ;;; minor mode commands to selectively display blocks of code|
  29. ;;; 18-Oct-1994|3.4|~/modes/hideshow.el.Z|
  30.  
  31. ;;; Commentary:
  32.  
  33. ;;; This file provides `hs-minor-mode'.  When active, six commands:
  34. ;;;   hs-{hide,show}-{all,block}, hs-show-region and hs-minor-mode
  35. ;;; are available.  They implement block hiding and showing.  Blocks are
  36. ;;; defined in mode-specific way.  In c-mode or c++-mode, they are simply
  37. ;;; curly braces, while in lisp-ish modes they are parens.  Multi-line
  38. ;;; comments (c-mode) can also be hidden.  The command M-x hs-minor-mode
  39. ;;; toggles the minor mode or sets it (similar to outline minor mode).
  40. ;;; See documentation for each command for more info.
  41. ;;;
  42. ;;; The variable `hs-unbalance-handler-method' controls hideshow's behavior
  43. ;;; in the case of "unbalanced parentheses".  See doc for more info.
  44.  
  45. ;;; Suggested usage:
  46.  
  47. ;;; (load-library "hideshow")
  48. ;;; (defun my-hs-setup () "enables hideshow and binds some commands"
  49. ;;;   (hs-minor-mode 1)
  50. ;;;   (define-key hs-minor-mode-map "\C-ch" 'hs-hide-block)
  51. ;;;   (define-key hs-minor-mode-map "\C-cs" 'hs-show-block)
  52. ;;;   (define-key hs-minro-mode-map "\C-cH" 'hs-hide-all)
  53. ;;;   (define-key hs-minro-mode-map "\C-cS" 'hs-show-all)
  54. ;;;   (define-key hs-minor-mode-map "\C-cR" 'hs-show-region))
  55. ;;; (add-hook 'X-mode-hook 'my-hs-setup t)   ; other modes similarly
  56. ;;;
  57. ;;; where X = {emacs-lisp,c,c++,perl,...}.  See the doc for the variable
  58. ;;; `hs-special-modes-alist' if you'd like to use hideshow w/ other modes.
  59.  
  60. ;;; Etc:
  61.  
  62. ;;; Bug reports and fixes welcome (comments, too).  Thanks go to
  63. ;;;    Dean Andrews <adahome@ix.netcom.com>
  64. ;;;    Preston F. Crow <preston.f.crow@dartmouth.edu>
  65. ;;;    Gael Marziou <gael@gnlab030.grenoble.hp.com>
  66. ;;;    Keith Sheffield <sheff@edcsgw2.cr.usgs.gov>
  67. ;;;    Jan Djarv <jan.djarv@sa.erisoft.se>
  68. ;;;    Lars Lindberg <qhslali@aom.ericsson.se>
  69. ;;;    Alf-Ivar Holm <alfh@ifi.uio.no>
  70. ;;; for valuable feedback, code and bug reports.
  71.  
  72. ;;; Code:
  73.  
  74.  
  75. ;;;----------------------------------------------------------------------------
  76. ;;; user-configurable variables
  77.  
  78. (defvar hs-unbalance-handler-method 'top-level
  79.   "*Symbol representing how \"unbalanced parentheses\" should be handled.
  80. This error is usually signalled by hs-show-block.  One of four values:
  81. `top-level', `next-line', `signal' or `ignore'.  Default is `top-level'.
  82.  
  83. - `top-level' -- Show top-level block containing the currently troublesome
  84. block.
  85. - `next-line' -- Use the fact that, for an already hidden block, its end
  86. will be on the next line.  Attempt to show this block.
  87. - `signal' -- Pass the error through, stopping execution.
  88. - `ignore' -- Ignore the error, continuing execution.
  89.  
  90. Values other than these four will be interpreted as `signal'.")
  91.  
  92. (defvar hs-special-modes-alist '((c-mode "{" "}")
  93.                  (c++-mode "{" "}"))
  94.   "*Alist of the form (MODE START-RE END-RE FORWARD-SEXP-FUNC).
  95. If present, hideshow will use these values for the start and end regexps,
  96. respectively.  Since Algol-ish languages do not have single-character
  97. block delimiters, the function `forward-sexp' which is used by hideshow
  98. doesn't work.  In this case, if a similar function is provided, you can
  99. register it and have hideshow use it instead of `forward-sexp'.  To add
  100. more values, use
  101.  
  102. \t(pushnew '(new-mode st-re end-re function-name)
  103. \t    hs-special-modes-alist :test 'equal)
  104.  
  105. For example:
  106.  
  107. \t(pushnew '(simula-mode \"begin\" \"end\" simula-next-statement)
  108. \t    hs-special-modes-alist :test 'equal)
  109.  
  110. Note that the regexps should not contain leading or trailing whitespace.")
  111.  
  112. (defvar hs-hide-hooks nil
  113.   "*Hooks called at the end of hs-hide-all and hs-hide-block.")
  114.  
  115. (defvar hs-show-hooks nil
  116.   "*Hooks called at the end of hs-show-all, hs-show-block and hs-show-region.")
  117.  
  118. (defvar hs-minor-mode-prefix "\C-c"
  119.   "*Prefix key to use for hideshow commands in hideshow minor mode.")
  120.  
  121.  
  122. ;;;----------------------------------------------------------------------------
  123. ;;; internal variables
  124.  
  125. (defvar hs-minor-mode nil
  126.   "Non-nil if using hideshow mode as a minor mode of some other mode.
  127. Use the command `hs-minor-mode' to toggle this variable.")
  128.  
  129. (defvar hs-minor-mode-map nil
  130.   "Mode map for hideshow minor mode.")
  131.  
  132. (defvar hs-menu-bar nil
  133.   "Menu bar for hideshow minor mode (Xemacs only).")
  134.  
  135. (defvar hs-c-start-regexp nil
  136.   "Regexp for beginning of comments.  Buffer-local.
  137. Differs from mode-specific comment regexps in that surrounding
  138. whitespace is stripped.")
  139.  
  140. (defvar hs-c-end-regexp nil
  141.   "Regexp for end of comments.  Buffer-local.
  142. See `hs-c-start-regexp'.")
  143.  
  144. (defvar hs-block-start-regexp nil
  145.   "Regexp for beginning of block.  Buffer-local.")
  146.  
  147. (defvar hs-block-end-regexp nil
  148.   "Regexp for end of block.  Buffer-local.")
  149.  
  150. (defvar hs-forward-sexp-func 'forward-sexp
  151.   "Function used to do a forward-sexp.  Should change for Algol-ish modes.
  152. For single-character block delimiters -- ie, the syntax table regexp for the
  153. character is either `(' or `)' -- `hs-forward-sexp-func' would just be
  154. `forward-sexp'.  For other modes such as simula, a more specialized function
  155. is necessary.")
  156.  
  157. (defvar hs-emacs-type 'fsf
  158.   "Used to support both FSF Emacs and Xemacs.")
  159.  
  160. (eval-when-compile
  161.   (if (string-match "xemacs\\|lucid" emacs-version)
  162.       (progn
  163.     (defvar current-menubar nil "")
  164.     (defun set-buffer-menubar (arg1))
  165.     (defun add-menu (arg1 arg2 arg3)))))
  166.  
  167.  
  168. ;;;----------------------------------------------------------------------------
  169. ;;; support funcs
  170.  
  171. ;; snarfed from outline.el, but added buffer-read-only
  172. (defun hs-flag-region (from to flag)
  173.   "Hides or shows lines from FROM to TO, according to FLAG.
  174. If FLAG is \\n (newline character) then text is shown, while if FLAG
  175. is \\^M \(control-M) the text is hidden."
  176.   (let ((modp (buffer-modified-p))
  177.     buffer-read-only)        ; nothing is immune
  178.     (unwind-protect (progn
  179.               (subst-char-in-region
  180.                from to
  181.                (if (= flag ?\n) ?\C-m ?\n)
  182.                flag t))
  183.       (set-buffer-modified-p modp))))
  184.  
  185. (defun hs-hide-block-at-point (&optional end)
  186.   "Hide block iff on block beginning, optional END means reposition at end." 
  187.   (if (looking-at hs-block-start-regexp)
  188.       (let* ((p (point))
  189.          (q (progn (funcall hs-forward-sexp-func 1) (point))))
  190.     (forward-line -1) (end-of-line)
  191.     (if (and (< p (point)) (> (count-lines p q) 1))
  192.         (hs-flag-region p (point) ?\C-m))
  193.     (goto-char (if end q p)))))
  194.  
  195. (defun hs-show-block-at-point (&optional end)
  196.   "Show block iff on block beginning.  Optional END means reposition at end."
  197.   (if (looking-at hs-block-start-regexp)
  198.       (let* ((p (point))
  199.          (q
  200.           (condition-case error    ; probably unbalanced paren
  201.           (progn
  202.             (funcall hs-forward-sexp-func 1)
  203.             (point))
  204.         (error
  205.          (cond
  206.           ((eq hs-unbalance-handler-method 'ignore)
  207.            ;; just ignore this block
  208.            (point))
  209.           ((eq hs-unbalance-handler-method 'top-level)
  210.            ;; try to get out of rat's nest and expose the whole func
  211.            (if (/= (current-column) 0) (beginning-of-defun))
  212.            (setq p (point))
  213.            (re-search-forward (concat "^" hs-block-start-regexp)
  214.                       (point-max) t 2)
  215.            (point))
  216.           ((eq hs-unbalance-handler-method 'next-line)
  217.            ;; assumption is that user knows what s/he's doing
  218.            (beginning-of-line) (setq p (point))
  219.            (end-of-line 2) (point))
  220.           (t
  221.            ;; pass error through -- this applies to `signal', too
  222.            (signal (car error) (cdr error))))))))
  223.     (hs-flag-region p q ?\n)
  224.     (goto-char (if end (1+ (point)) p)))))
  225.  
  226. (defun hs-safety-is-job-n ()
  227.   "Warns if selective-display or selective-display-ellipses is nil."
  228.   (let ((str ""))
  229.     (or selective-display
  230.     (setq str "selective-display nil "))
  231.     (or selective-display-ellipses
  232.     (setq str (concat str "selective-display-ellipses nil")))
  233.     (if (= (length str) 0)
  234.     nil
  235.       (message "warning: %s" str)
  236.       (sit-for 2))))
  237.  
  238. (defun hs-inside-comment-p ()
  239.   "Returns non-nil if point is inside a comment, otherwise nil.
  240. Actually, for multi-line-able comments, returns a list containing
  241. the buffer position of the start and the end of the comment."
  242.   ;; is it single-line-only or multi-line-able?
  243.   (save-excursion
  244.     (let ((p (point))
  245.       q)
  246.       (if (string= comment-end "")    ; single line
  247.       (let (found)
  248.         (beginning-of-line)
  249.         (setq found (re-search-forward hs-c-start-regexp p t))
  250.         (and found (not (search-forward "\"" p t))))
  251.     (re-search-forward hs-c-end-regexp (point-max) 1)
  252.     (setq q (point))
  253.     (forward-comment -1)
  254.     (re-search-forward hs-c-start-regexp (point-max) 1)
  255.     (if (< (- (point) (length comment-start)) p)
  256.         (list (match-beginning 0) q)))))) 
  257.  
  258. (defun hs-grok-mode-type ()
  259.   "Setup variables for new buffers where applicable."
  260.   (if (and (boundp 'comment-start)
  261.        (boundp 'comment-end))
  262.       (progn
  263.     (setq hs-c-start-regexp (regexp-quote comment-start))
  264.     (if (string-match " +$" hs-c-start-regexp)
  265.         (setq hs-c-start-regexp
  266.           (substring hs-c-start-regexp 0 (1- (match-end 0)))))
  267.     (setq hs-c-end-regexp (if (string= "" comment-end) "\n"
  268.                 (regexp-quote comment-end)))
  269.     (if (string-match "^ +" hs-c-end-regexp)
  270.         (setq hs-c-end-regexp
  271.           (substring hs-c-end-regexp (match-end 0))))
  272.     (let ((lookup (assoc major-mode hs-special-modes-alist)))
  273.       (setq hs-block-start-regexp (or (nth 1 lookup) "\\s\(")
  274.         hs-block-end-regexp (or (nth 2 lookup) "\\s\)")
  275.         hs-forward-sexp-func (or (nth 3 lookup) 'forward-sexp))))))
  276.  
  277. (defun hs-find-block-beginning ()
  278.   "Repositions point at block-start.  Return point, or nil if top-level." 
  279.   (let (done
  280.     (here (point))
  281.     (both-regexps (concat "\\(" hs-block-start-regexp "\\)\\|\\("
  282.                   hs-block-end-regexp "\\)")))
  283.     (while (and (not done)
  284.         (re-search-backward both-regexps (point-min) t))
  285.       (if (match-beginning 1)        ; start of start-regexp
  286.       (setq done (match-beginning 1))
  287.     (goto-char (match-end 2))    ; end of end-regexp
  288.     (funcall hs-forward-sexp-func -1)))
  289.     (goto-char (or done here))
  290.     done))
  291.  
  292. (defmacro hs-life-goes-on (&rest body)
  293.   "Executes optional BODY iff variable `hs-minor-mode' is non-nil."
  294.   (list 'if 'hs-minor-mode (cons 'progn body)))
  295.  
  296.  
  297. ;;;----------------------------------------------------------------------------
  298. ;;; commands
  299.  
  300. ;;;###autoload
  301. (defun hs-hide-all ()
  302.   "Hides all top-level blocks, displaying only first and last lines.
  303. When done, point is repositioned at the beginning of the line, and
  304. hs-hide-hooks is called.  See documentation for `run-hooks'."
  305.   (interactive)
  306.   (hs-life-goes-on
  307.    (message "hiding all blocks ...")
  308.    (save-excursion
  309.      (hs-flag-region (point-min) (point-max) ?\n) ; eliminate weirdness
  310.      (goto-char (point-min))
  311.      (let ((count 0)
  312.        (top-level-re (concat "^" hs-block-start-regexp)))
  313.        (while (progn
  314.         (forward-comment (buffer-size))
  315.         (re-search-forward top-level-re (point-max) t))
  316.      (goto-char (match-beginning 0))
  317.      (hs-hide-block-at-point t)
  318.      (message "hiding ... %d" (setq count (1+ count)))))
  319.      (hs-safety-is-job-n))
  320.    (beginning-of-line)
  321.    (message "hiding all blocks ... done")
  322.    (run-hooks 'hs-hide-hooks)))
  323.  
  324. (defun hs-show-all ()
  325.   "Shows all top-level blocks.
  326. When done, point is unchanged, and hs-show-hooks is called.  See
  327. documentation for `run-hooks'."
  328.   (interactive)
  329.   (hs-life-goes-on
  330.    (message "showing all blocks ...")
  331.    (hs-flag-region (point-min) (point-max) ?\n)
  332.    (message "showing all blocks ... done")
  333.    (run-hooks 'hs-show-hooks)))
  334.  
  335. ;;;###autoload
  336. (defun hs-hide-block (&optional end)
  337.   "Selects a block and hides it.  With prefix arg, reposition at end.
  338. Block is defined as a sexp for lispish modes, mode-specific otherwise.
  339. Comments are blocks, too.  Upon completion, point is at repositioned and
  340. hs-hide-hooks is called.  See documentation for `run-hooks'."
  341.   (interactive "P")
  342.   (hs-life-goes-on
  343.    (let ((c-reg (hs-inside-comment-p)))
  344.      (if c-reg
  345.      (cond ((string= comment-end "")
  346.         (message "can't hide a single-line comment"))
  347.            ((< (count-lines (car c-reg) (nth 1 c-reg)) 2)
  348.         (message "not enougn comment lines to hide"))
  349.            (t
  350.         (goto-char (nth 1 c-reg))
  351.         (forward-line -1)
  352.         (hs-flag-region (car c-reg) (point) ?\C-m)
  353.         (goto-char (if end (nth 1 c-reg) (car c-reg)))
  354.         (hs-safety-is-job-n)
  355.         (run-hooks 'hs-hide-hooks)))
  356.        (if (or (looking-at hs-block-start-regexp)
  357.            (hs-find-block-beginning))
  358.        (progn
  359.          (hs-hide-block-at-point end)
  360.          (hs-safety-is-job-n)
  361.          (run-hooks 'hs-hide-hooks)))))))
  362.  
  363. (defun hs-show-block (&optional end)
  364.   "Selects a block and shows it.  With prefix arg, reposition at end.
  365. Upon completion, point is repositioned hs-show-hooks are called.  See
  366. documetation for `hs-hide-block' and `run-hooks'."
  367.   (interactive "P")
  368.   (hs-life-goes-on
  369.    (let ((c-reg (hs-inside-comment-p)))
  370.      (if c-reg
  371.      (cond ((string= comment-end "")
  372.         (message "already looking at the entire comment"))
  373.            (t
  374.         (hs-flag-region (car c-reg) (nth 1 c-reg) ?\n)
  375.         (goto-char (if end (nth 1 c-reg) (car c-reg)))))
  376.        (if (or (looking-at hs-block-start-regexp)
  377.            (hs-find-block-beginning))
  378.        (progn
  379.          (hs-show-block-at-point end)
  380.          (hs-safety-is-job-n)
  381.          (run-hooks 'hs-show-hooks)))))))
  382.  
  383. (defun hs-show-region (beg end)
  384.   "Shows all lines from BEG to END, without doing any block analysis.
  385. Note: hs-show-region is intended for use when when hs-show-block signals
  386. `unbalanced parentheses' and so is an emergency measure only.  You may
  387. become very confused if you use this command indiscriminately."
  388.   (interactive "r")
  389.   (hs-life-goes-on
  390.    (hs-flag-region beg end ?\n)
  391.    (hs-safety-is-job-n)
  392.    (run-hooks 'hs-show-hooks)))
  393.  
  394. ;;;###autoload
  395. (defun hs-minor-mode (&optional arg)
  396.   "Toggle hideshow minor mode.
  397. With ARG, turn hideshow minor mode on if ARG is positive, off otherwise.
  398. When hideshow minor mode is on, the menu bar is augmented with hideshow
  399. commands and the hideshow commands are enabled.  The variables\n
  400. \tselective-display\n\tselective-display-ellipses\n
  401. are set to t.  Lastly, the hooks set in hs-minor-mode-hook are called.
  402. See documentation for `run-hooks'.\n
  403. Turning hideshow minor mode off reverts the menu bar and the
  404. variables to default values and disables the hideshow commands."
  405.   (interactive "P")
  406.   (setq hs-minor-mode
  407.         (if (null arg)
  408.         (not hs-minor-mode)
  409.           (> (prefix-numeric-value arg) 0)))
  410.   (if hs-minor-mode
  411.       (progn
  412.      (if (eq hs-emacs-type 'lucid)
  413.         (progn
  414.           (set-buffer-menubar (copy-sequence current-menubar))
  415.           (add-menu nil (car hs-menu-bar) (cdr hs-menu-bar))))
  416.     (setq selective-display t
  417.           selective-display-ellipses t)
  418.     (hs-grok-mode-type)
  419.     (run-hooks 'hs-minor-mode-hook))
  420.     (if (eq hs-emacs-type 'lucid)
  421.     (set-buffer-menubar (delete hs-menu-bar current-menubar)))
  422.     (kill-local-variable 'selective-display)
  423.     (kill-local-variable 'selective-display-ellipses)))
  424.  
  425.  
  426. ;;;----------------------------------------------------------------------------
  427. ;;; load-time setup routines
  428.  
  429. ;; which emacs being used?
  430. (setq hs-emacs-type
  431.       (if (string-match "XEmacs\\|Lucid" emacs-version)
  432.       'lucid
  433.     'fsf))
  434.  
  435. ;; keymaps and menus
  436. (if (not hs-minor-mode-map)
  437.   (setq hs-minor-mode-map (make-sparse-keymap))
  438.   (cond
  439.    ((eq hs-emacs-type 'lucid)
  440.     (setq hs-menu-bar            ; build top down for lucid
  441.       '("hideshow"
  442.         ["Hide Block" hs-hide-block t]
  443.         ["Show Block" hs-show-block t]
  444.         ["Hide All" hs-hide-all t]
  445.         ["Show All" hs-show-all t]
  446.         ["Show Region" hs-show-region t])))
  447.    (t                    ; build bottom up for others
  448.     (define-key hs-minor-mode-map [menu-bar hideshow]
  449.       (cons "hideshow" (make-sparse-keymap "hideshow")))
  450.     (define-key hs-minor-mode-map [menu-bar hideshow hs-show-region]
  451.       '("Show Region" . hs-show-region))
  452.     (define-key hs-minor-mode-map [menu-bar hideshow hs-show-all]
  453.       '("Show All" . hs-show-all))
  454.     (define-key hs-minor-mode-map [menu-bar hideshow hs-hide-all]
  455.       '("Hide All" . hs-hide-all))
  456.     (define-key hs-minor-mode-map [menu-bar hideshow hs-show-block]
  457.       '("Show Block" . hs-show-block))
  458.     (define-key hs-minor-mode-map [menu-bar hideshow hs-hide-block]
  459.       '("Hide Block" . hs-hide-block)))))
  460.  
  461. ;; some housekeeping
  462. (or (assq 'hs-minor-mode minor-mode-map-alist)
  463.     (setq minor-mode-map-alist
  464.           (cons (cons 'hs-minor-mode hs-minor-mode-map)
  465.                 minor-mode-map-alist)))
  466. (or (assq 'hs-minor-mode minor-mode-alist)
  467.     (setq minor-mode-alist (append minor-mode-alist
  468.                                    (list '(hs-minor-mode " hs")))))
  469.  
  470. ;; make some variables buffer-local
  471. (make-variable-buffer-local 'hs-minor-mode)
  472. (make-variable-buffer-local 'hs-c-start-regexp)
  473. (make-variable-buffer-local 'hs-c-end-regexp)
  474. (make-variable-buffer-local 'hs-block-start-regexp)
  475. (make-variable-buffer-local 'hs-block-end-regexp)
  476. (make-variable-buffer-local 'hs-forward-sexp-func)
  477. (put 'hs-minor-mode 'permanent-local t)
  478. (put 'hs-c-start-regexp 'permanent-local t)
  479. (put 'hs-c-end-regexp 'permanent-local t)
  480. (put 'hs-block-start-regexp 'permanent-local t)
  481. (put 'hs-block-end-regexp 'permanent-local t)
  482. (put 'hs-forward-sexp-func 'permanent-local t)
  483.  
  484.  
  485. ;;;----------------------------------------------------------------------------
  486. ;;; that's it
  487.  
  488. (provide 'hideshow)
  489.  
  490. ;;; hideshow.el ends here
  491.